home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Test / Harness / Point.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  3.3 KB  |  144 lines
  1. # -*- Mode: cperl; cperl-indent-level: 4 -*-
  2. package Test::Harness::Point;
  3.  
  4. use strict;
  5. use vars qw($VERSION);
  6. $VERSION = '0.01';
  7.  
  8. =head1 NAME
  9.  
  10. Test::Harness::Point - object for tracking a single test point
  11.  
  12. =head1 SYNOPSIS
  13.  
  14. One Test::Harness::Point object represents a single test point.
  15.  
  16. =head1 CONSTRUCTION
  17.  
  18. =head2 new()
  19.  
  20.     my $point = new Test::Harness::Point;
  21.  
  22. Create a test point object.
  23.  
  24. =cut
  25.  
  26. sub new {
  27.     my $class = shift;
  28.     my $self  = bless {}, $class;
  29.  
  30.     return $self;
  31. }
  32.  
  33. =head1 from_test_line( $line )
  34.  
  35. Constructor from a TAP test line, or empty return if the test line
  36. is not a test line.
  37.  
  38. =cut
  39.  
  40. sub from_test_line  {
  41.     my $class = shift;
  42.     my $line = shift or return;
  43.  
  44.     # We pulverize the line down into pieces in three parts.
  45.     my ($not, $number, $extra) = ($line =~ /^(not )?ok\b(?:\s+(\d+))?\s*(.*)/) or return;
  46.  
  47.     my $point = $class->new;
  48.     $point->set_number( $number );
  49.     $point->set_ok( !$not );
  50.  
  51.     if ( $extra ) {
  52.         my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
  53.         $description =~ s/^- //; # Test::More puts it in there
  54.         $point->set_description( $description );
  55.         if ( $directive ) {
  56.             $point->set_directive( $directive );
  57.         }
  58.     } # if $extra
  59.  
  60.     return $point;
  61. } # from_test_line()
  62.  
  63. =head1 ACCESSORS
  64.  
  65. Each of the following fields has a getter and setter method.
  66.  
  67. =over 4
  68.  
  69. =item * ok
  70.  
  71. =item * number
  72.  
  73. =cut
  74.  
  75. sub ok              { my $self = shift; $self->{ok} }
  76. sub set_ok          {
  77.     my $self = shift;
  78.     my $ok = shift;
  79.     $self->{ok} = $ok ? 1 : 0;
  80. }
  81. sub pass {
  82.     my $self = shift;
  83.  
  84.     return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
  85. }
  86.  
  87. sub number          { my $self = shift; $self->{number} }
  88. sub set_number      { my $self = shift; $self->{number} = shift }
  89.  
  90. sub description     { my $self = shift; $self->{description} }
  91. sub set_description {
  92.     my $self = shift;
  93.     $self->{description} = shift;
  94.     $self->{name} = $self->{description}; # history
  95. }
  96.  
  97. sub directive       { my $self = shift; $self->{directive} }
  98. sub set_directive   {
  99.     my $self = shift;
  100.     my $directive = shift;
  101.  
  102.     $directive =~ s/^\s+//;
  103.     $directive =~ s/\s+$//;
  104.     $self->{directive} = $directive;
  105.  
  106.     my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
  107.     $self->set_directive_type( $type );
  108.     $reason = "" unless defined $reason;
  109.     $self->{directive_reason} = $reason;
  110. }
  111. sub set_directive_type {
  112.     my $self = shift;
  113.     $self->{directive_type} = lc shift;
  114.     $self->{type} = $self->{directive_type}; # History
  115. }
  116. sub set_directive_reason {
  117.     my $self = shift;
  118.     $self->{directive_reason} = shift;
  119. }
  120. sub directive_type  { my $self = shift; $self->{directive_type} }
  121. sub type            { my $self = shift; $self->{directive_type} }
  122. sub directive_reason{ my $self = shift; $self->{directive_reason} }
  123. sub reason          { my $self = shift; $self->{directive_reason} }
  124. sub is_todo {
  125.     my $self = shift;
  126.     my $type = $self->directive_type;
  127.     return $type && ( $type eq 'todo' );
  128. }
  129. sub is_skip {
  130.     my $self = shift;
  131.     my $type = $self->directive_type;
  132.     return $type && ( $type eq 'skip' );
  133. }
  134.  
  135. sub diagnostics     {
  136.     my $self = shift;
  137.     return @{$self->{diagnostics}} if wantarray;
  138.     return join( "\n", @{$self->{diagnostics}} );
  139. }
  140. sub add_diagnostic  { my $self = shift; push @{$self->{diagnostics}}, @_ }
  141.  
  142.  
  143. 1;
  144.